perm filename SYSTEM.LSP[1,JRA] blob sn#011362 filedate 1972-11-08 generic text, type T, neo UTF8
COMMENT ⊗   VALID 00007 PAGES 
RECORD PAGE   DESCRIPTION
 00001 00001
 00002 00002	changes that must be made by hand to the CNVR code:
 00004 00003	(SETQ DEBUGLOOP NIL)
 00006 00004	(DF DO (L)
 00008 00005	(PUTPROP @LIST# (GET @LIST @FSUBR) @FSUBR)
 00010 00006	(DEFPROP AND (LAMBDA ($L)
 00013 00007	
 00015 ENDMK
⊗;
COMMENT changes that must be made by hand to the CNVR code:

FILE	FCN		PROBLEM

DB	DATA-INIT	(ARRAY FRAMES NIL---
			in stanford lisp the nil means real number array---
			in mac lisp it means don't protect from gc---
	change to	(ARRAY FRAMES T---

anytime a file is SOSed, it gets CRs added to LFs---look for (QUOTE //) as an
indication of this condition---delete the second / and the )

To convert a MACLISP file to STANFORD LISP do:
R LISP 30<RETURN>
(DSKIN (UTIL.LAP))<RETURN>
(CONVERT)<RETURN>
	then, answer the file naming questions-
	if the extension for the file is TMP, then the conversion routine
	assumes the macro conversion has already been done and starts
	with the LAMBDA conversion-
;

(SETQ DEBUGLOOP NIL)

(*RSET T)
(DM TRACE (L)
 (PROG2	(DSKIN TRACE)(LIST (QUOTE QUOTE) (EVAL L))))

(PUTPROP @DIFFERENCE (GET @*DIF @SUBR) @SUBR)

(PUTPROP @SASSQ (GET @SASSOC @SUBR) @SUBR)

(PUTPROP @MAPC# (GET @MAPC @SUBR) @SUBR)

(PUTPROP @MAPCAR# (GET @MAPCAR @SUBR) @SUBR)

(PUTPROP @ASSQ (GET @ASSOC @SUBR) @SUBR)

(PUTPROP @APPLY# (GET @APPLY @LSUBR) @LSUBR)

(DF DECLARE (L) (APPEND @(DECLARE) L))

(DECLARE (*FEXPR SSTATUS DECLARE GENPREFIX ))
(DECLARE (*EXPR SPRINT))

(SETQ PURE NIL)

(SETQ ERRLIST NIL)
(SETQ EAR 0)
(SETQ FRAMEVARS NIL)
(SETQ CINTERRUPT NIL)
(SETQ EXP NIL)
(SETQ ALINK NIL)
(SETQ FRAME* NIL)
(SETQ BVARS NIL)
(SETQ CLINK NIL)
(SETQ *ITEMS NIL)
(SETQ NUMACT 0.)

(DF PAGEBPORG (L) @PAGEBPORG)

(DF GENPREFIX (L) @GENPREFIX)

(DF DO (L)
 (PROG ($X $XI $XS $ET $BD)
	(*SQ $X (CAR L))
	(*SQ $XI (CADR L))
	(*SQ $XS (CADDR L))
	(*SQ $ET (CADDDR L))
	(*SQ $BD (CDDDDR L))
START
	(SET $X $XI)
DOLOOP
	(COND ((EVAL $ET)(RETURN NIL)))
	(MAPC @EVAL $BD)
	(SET $X (EVAL $XS))
	(GO DOLOOP) ))

(DE DELETE $N
((LABEL #DEL (LAMBDA ($X $L $T)
  (COND ((NULL $L) NIL)
	((EQUAL $X (CAR $L))
	 (COND ((EQUAL $T 1)(CDR $L))
	       (T (#DEL $X (CDR $L) (SUB1 $T)))) )
	(T (CONS (CAR $L)(#DEL $X (CDR $L) $T))))))

 (ARG 1)
 (ARG 2)
 (OR (AND (= $N 3)(ARG 3))
      1) ))

(DE DELQ $N
((LABEL #DEL (LAMBDA ($X $L $T)
  (COND ((NULL $L) NIL)
	((EQ $X (CAR $L))
	 (COND ((EQUAL $T 1)(CDR $L))
	       (T (#DEL $X (CDR $L) (SUB1 $T)))) )
	(T (CONS (CAR $L)(#DEL $X (CDR $L) $T))))))

 (ARG 1)
 (ARG 2)
 (OR (AND (= $N 3)(ARG 3))
      1) ))

(PUTPROP @LIST# (GET @LIST @FSUBR) @FSUBR)

(DEFPROP LIST
 (LAMBDA $N
  ((LABEL LIST1 (LAMBDA ($X)
    (COND ((EQUAL $X (ADD1 $N)) NIL)
	  (T (CONS (ARG $X)(LIST1 (ADD1 $X)))))))
   1))
 EXPR)

(REMPROP @LIST @FSUBR)

(DE ASSOC ($A $L)
(COND ((NULL $L) NIL)
	((EQUAL $A (CAAR $L))(CAR $L))
	(T (ASSOC $A (CDR $L)))))

(DEFPROP  MIN (LAMBDA  $N
(PROG ($V)
(SETQ $V (ARG $N))
A (SETQ $N (SUB1 $N))
(COND ((ZEROP $N)(RETURN $V)) 
      ((LESSP (ARG $N) $V) (SETQ $V (ARG $N))))
(GO A)))EXPR)

(DEFPROP  MAX (LAMBDA  $N
(PROG ($V)
(SETQ $V (ARG $N))
A (SETQ $N (SUB1 $N))
(COND ((ZEROP $N)(RETURN $V)) 
      ((GREATERP (ARG $N) $V)(SETQ $V (ARG $N))))
(GO A)))EXPR)

(DEFPROP MEMQ (LAMBDA ($E $L)
(COND ((NULL $L) NIL)
	((NOT (ATOM (CAR $L)))(MEMQ $E (CDR $L)))
	((EQ $E (CAR $L)) $L)
	(T (MEMQ $E (CDR $L)))))EXPR)

(DEFPROP MEMBER (LAMBDA ($E $L)
(COND ((NULL $L) NIL)
	((EQUAL $E (CAR $L)) $L)
	(T (MEMBER $E (CDR $L)))))EXPR)

(DEFPROP RANDOM (LAMBDA ()
(QUOTIENT (TIMES  (EXAMINE 15)(EXAMINE 16) ) (MAX (EXAMINE 15)(EXAMINE 16)))
)EXPR)


(DEFPROP AND (LAMBDA ($L)
(AND# (CDR $L))) MACRO)

(DEFPROP AND# (LAMBDA ($L)
(COND ((NULL (CDR $L))(LIST (QUOTE COND)(LIST (CAR $L))))
(T (LIST (QUOTE COND)(LIST (CAR $L)(AND# (CDR $L)))))))EXPR)

(DEFPROP OR  (LAMBDA ($L)
(OR# (CDR $L)))
MACRO)

(DEFPROP OR# (LAMBDA ($L)
(APPEND (QUOTE (COND))(MAPCAR (FUNCTION LIST) $L)))
EXPR)

(PUTPROP @AND @(LAMBDA ($L)
(AND# (CDR $L))) @MACRO)

(PUTPROP @OR  @(LAMBDA ($L)
(OR# (CDR $L)))
@MACRO)

(DEFPROP MAPCAR (LAMBDA $L
(COND	((GREATERP $L 3)(PRINT @(MAPCAR OF 3 ARG LISTS))(ERR))
	((EQUAL $L 2)(MAPCAR# (ARG 1)(ARG 2)))
(T (COND ((OR (NULL (ARG 2))(NULL (ARG 3)))NIL)
(T (CONS ((ARG 1)(CAR (ARG 2))(CAR (ARG 3)))
(MAPCAR (ARG 1)(CDR (ARG 2))(CDR (ARG 3)))))))))EXPR)

(DEFPROP MAPC (LAMBDA $L
	(COND	((GREATERP $L 4)(PRINT @(MAPC OF FOUR ARG LISTS))(ERR))
	((EQUAL $L 2)(MAPC# (ARG 1)(ARG 2)) (ARG 2) )
	((EQUAL $L 3)
		(PROG ($A $B) 
			(SETQ $A (ARG 2))(SETQ $B (ARG 3)) 
		L1 (AND (OR (NULL $A)(NULL $B))(RETURN (ARG 2)) )
			   ((ARG 1)(CAR $A)(CAR $B))
			     (SETQ $A (CDR $A))(SETQ $B (CDR $B))
				(GO L1 )))
	(T (PROG ($A $B $C) (SETQ $A (ARG 2))(SETQ $B (ARG 3))(SETQ $C(ARG 4)) 
		L1 (AND (OR (NULL $A)(NULL $B)(NULL $C))(RETURN (ARG 2)))
		   ((ARG 1)(CAR $A)(CAR $B)(CAR $C))
		   (SETQ $A(CDR $A))(SETQ $B (CDR $B))(SETQ $C(CDR $C))
		   (GO L1)))))EXPR)

(DECLARE (SPECIAL $R $F $L))

(DEFPROP MAPCAN
 (LAMBDA($F $L)
  (PROG ($R)
(MAPC(FUNCTION (LAMBDA($X)(SETQ $R(NCONC $R ($F $X)))))$L)
(RETURN $R)))
EXPR)

(DECLARE (UNSPECIAL $R $F $L))



(DEFPROP APPLY
 (LAMBDA $L
	 (COND	((GETL (ARG 1) (QUOTE (EXPR LSUBR SUBR)))
		 (APPLY# (ARG 1)(ARG 2)))
		((EVAL (CONS (ARG 1)(ARG 2))))))
 EXPR)

(DM PP ($L) (LIST @GRINDEF (EVAL (CADR $L))))


(DF CATCH ($N) (EVAL (CAR $N)))
(DF THROW ($N) (EVAL (CAR $N)))

(PUTPROP @/= (GET @EQUAL @SUBR) @SUBR)
(PUTPROP @/< (GET @*LESS @SUBR) @SUBR)
(PUTPROP @/> (GET @*GREAT @SUBR) @SUBR)
(PUTPROP @/+ (GET @*PLUS @SUBR) @SUBR)
(PUTPROP @/1+ (GET @ADD1 @SUBR) @SUBR)
(PUTPROP @/1- (GET @SUB1 @SUBR) @SUBR)
(PUTPROP @/- (GET @*DIF @SUBR) @SUBR)

(DF MAKREADTABLE (L) (APPEND @(MAKREADTABLE) L))
(DF SSTATUS (L) (APPEND @(SSTATUS) L))
(DF GLOBAL (L) (APPEND @(GLOBAL) L))
(DF FUNCTIONS (L) (APPEND @(FUNCTIONS) L))

(DE BOUNDP (L) (GET L @VALUE))

(PUTPROP @*SQ (GET @SETQ @FSUBR) @FSUBR)

(DF SETQ ($#%L)
 (PROG ($#%X)
A	(COND ((NULL $#%L)(RETURN $#%X)))
	(*SQ $#%X (SET (EVAL @(CAR $#%L))(EVAL (CADR $#%L)) ))
	(*SQ $#%L (CDDR $#%L))
	(GO A)))

(PUTPROP @*GT (GET @GET @SUBR) @SUBR)
(DE GET ($X $I)(COND ((NUMBERP $X)NIL)(T(*GT $X $I))))